home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / XLISP 3.0a1 / QQUOTE.LSP < prev    next >
Text File  |  1995-03-11  |  1KB  |  45 lines
  1. #|
  2.  
  3. Quasiquote expander for XLISP 3.0
  4.  
  5. Derived from the code in Appendix C of "Common Lisp" by Guy L. Steele Jr.
  6. without the simplifier for now.
  7.  
  8. |#
  9.  
  10. (define (qq-process x)
  11.   (cond ((symbol? x)
  12.          (list 'quote x))
  13.         ((atom? x)
  14.          x)
  15.         ((eq? (car x) 'quasiquote)
  16.          (qq-process (qq-process (cadr x))))
  17.         ((eq? (car x) 'unquote)
  18.          (cadr x))
  19.         ((eq? (car x) 'unquote-splicing)
  20.          (error ",@ after ` in ~S" (cadr x)))
  21.         (else
  22.          (let loop ((p x) (q '()))
  23.            (if (atom? p)
  24.              (cons 'append
  25.                    (append (reverse q) (list (if (symbol? p) (list 'quote p) p))))
  26.              (begin
  27.                (if (eq? (car p) 'unquote)
  28.                  (begin
  29.                    (if (cddr p) (error "malformed , in ~S" p))
  30.                    (cons 'append
  31.                          (append (reverse q) (list (cadr p)))))
  32.                  (if (eq? (car p) 'unquote-splicing)
  33.                    (error "dotted ,@ in ~S" p)
  34.                    (loop (cdr p) (cons (qq-bracket (car p)) q))))))))))
  35.                
  36. (define (qq-bracket x)
  37.   (cond ((atom? x)
  38.          (list 'list (qq-process x)))
  39.         ((eq? (car x) 'unquote)
  40.          (list 'list (cadr x)))
  41.         ((eq? (car x) 'unquote-splicing)
  42.          (cadr x))
  43.         (else
  44.          (list 'list (qq-process x)))))
  45.